Dictionaries & Language/Dictionaries and Language (Chestnut CD-ROM) (1993).iso/misc/vb30/vb-blk1.inc

Text File | 1986-02-07 | 9.6 KB | 368 lines

{************************************************************************}
{*                                                                      *}
{*           VB Support Procedures and Functions -- Block 1             *}
{*                                                                      *}
{*         Spaces             Beep                   Ask                *}
{*         Center             Pad                    Pause              *}
{*         ReadResponse       PrintPageHeader        List               *}
{*         Exist              ExistFile              AskDir             *}
{*         GetListName        ReadList               WriteList          *}
{*         SetPage            SetRandomOrder         SetSequence        *}
{*                            StudyReport                               *}
{*                                                                      *}
{************************************************************************}


  procedure Spaces (S : integer);
  { write S spaces to the screen }
    var
      i  : integer;
    begin
      for i := 1 to S do
        write (' ')
    end;


  procedure Beep;
  { ring the console bell }
    begin
      write (chr(BEL))
    end;


  function Ask(S : AnyString): boolean;
  { ask a yes/no question and get the response }
    var
      i  : integer;
      ch : char;
    begin
      spaces(12);
      write (S + ' (Y/N)? ');
      repeat
        read (kbd,ch);
        if ch in ['Y','y']
          then
            write ('Yes')
          else
            if ch in ['N','n']
              then
                write ('No')
              else
                Beep
      until (ch in ['Y','y','N','n']);
      ask := (ch in ['Y','y'])
    end;


  procedure Center (S : AnyString; LineFeed : boolean);
  { center a string on the console screen }
    var
      i : integer;
    begin
      i := (77 - length(S)) div 2;
      spaces (i);
      write (S);
      if LineFeed
        then
          writeln
    end;


  function Pad(S: FullWord; L: integer): FullWord;
  { pad a string with blanks }
    var
      NumBlanks : integer;
      i         : integer;
      SS        : FullWord;
    begin
      NumBlanks := L - length(S) + 5;
      SS := S;
      for i := 1 to NumBlanks do
        SS := SS + ' ';
      Pad := SS
    end;


  procedure Pause;
  { give 'em a chance to read the screen }
    begin
      GoToXY (1,24);
      spaces(14);
      write ('Press any character to continue...');
      read (kbd,Response)
    end;


  procedure ReadResponse (Answers: Charset);
  { get a character from the keyboard }
    begin
      center ('What is your pleasure? ',FALSE);
      repeat
        read (kbd,Response);
        Response := UpCase(Response);
        if not (Response in Answers)
          then
            Beep
          else
            write (Response)
      until (Response in Answers)
    end;


  procedure PrintPageHeader (SubHead : AnyString);
  { put a standard header at the top of the console screen }
    var
      i          : integer;
      UnderScore : AnyString;
    begin
      ClrScr;
      for i := 1 to 78 do
        write ('-');
      writeln ('-');
      center (Language + ' Vocabulary Builder -- ' + VerMsg,TRUE);
      for i := 1 to 78 do
        write ('-');
      writeln ('-');
      if length(SubHead) > 0
        then
          begin
            writeln;
            center(SubHead,TRUE);
            UnderScore := '';
            for i := 1 to length(SubHead) do
              UnderScore := UnderScore + '-';
            center(UnderScore,TRUE)
          end
    end;


  procedure List (ch: char;var FileID: text);
  { list selected help text }
    var
      i         : integer;
      line      : TextString;
    begin
      reset (FileID);
      repeat
        readln (FileID, line)
      until EOF(FileID) or (line[1] = ':') and (line[2] = ch);
      readln (FileID,line);
      while (line[1] <> ':') and not EOF(FileID) do
        begin
          for i := 1 to length(line) do
            if line[i] <> LangFlag
              then
                write (line[i])
              else
                write (Language);
          write (chr(CR),chr(LF));
          readln (FileID,line)
        end
      end;


  function Exist (var FileID : text; FName : AnyString): boolean;
  { check for the existence of a text file on disk }
    begin
      assign (FileID,FName);
      {$I-} reset (FileID) {$I+};
      Exist := (IOresult = 0)
    end;


  function ExistFile (var FileID : ListFile; FName : AnyString): boolean;
  { check for the existence of a word list file on disk }
    begin
      assign (FileID,FName);
      {$I-} reset (FileID) {$I+};
      ExistFile := (IOresult = 0)
    end;


  procedure AskDir;
  { check to see if a directory listing is required }
    begin
      if ask ('Would you like to see what lists are available')
        then
          begin
            writeln;
            DirWordList
          end
        else
          writeln
    end;


  procedure GetListName(var N: ListName; Prompt: AnyString; TypeOfGet: integer);
  { prompt for the name of a word list }
    begin
      if TypeOfGet = 1
        then
          begin
            spaces(12);
            write ('Which list would you like to ',Prompt,'? ')
          end
        else
          begin
            spaces(12);
            write (Prompt,'? ')
          end;
      readln (N)
    end;


  procedure ReadList (var N: integer; var List: WordList; var Name: ListName);
  { fetch a word list into memory }
    var
      FileID     : ListFile;
      FName      : FileName;
      i          : integer;
    begin
      for i := 1 to length(Name) do
        Name[i] := UpCase(Name[i]);
      FName := Name + '.' + Extent;
      N := 0;
      if ExistFile(FileID,FName)
        then
          begin
            while not EOF(FileID) do
              begin
                N := N + 1;
                read (FileID,List[N])
              end;
            close (FileID)
          end
        else
          begin
            writeln;
            spaces(12);
            write ('I can''t find that list.')
          end
    end;


  procedure WriteList (N: integer;List: WordList; var Name: ListName);
  { write a word list to disk }
    var
      FileID     : ListFile;
      FName      : FileName;
      i          : integer;
    begin
      for i := 1 to length(Name) do
        Name[i] := UpCase(Name[i]);
      FName := Name + '.' + Extent;
      assign (FileID,FName);
      rewrite (FileID);
      for i := 1 to N do
        write (FileID,List[i]);
      close (FileID)
    end;


  procedure SetPage (Header: AnyString; SP1: integer; Col1: AnyString;
                     SP2: integer; Col2: AnyString);
  { repaint the screen with appropriate headers }
    begin
      PrintPageHeader(Header);
      writeln;
      spaces(Sp1);
      write (Col1);
      spaces(Sp2);
      write (Col2)
    end;


  procedure SetRandomOrder (var Order: Ordering; N: integer);
  { select a random ordering for list presentation }
    var
      Flag    : OrderFlag;
      i,j     : integer;
    begin
      Randomize;
      for i := 1 to N do
        Flag[i] := ' ';
      j := 1;
      while j <= N do
        begin
          i := round(random(N)+1.0);
          if Flag[i] = ' '
            then
              begin
                Order[j] := i;
                Flag[i] := '*';
                j := succ(j)
              end
        end
    end;


  function SetSequence(T: boolean): boolean;
  { find out in which direction to present the word list }
    var
      ch  : char;
    begin
      writeln;
      spaces(12);
      writeln ('How would you like the word list presented:');
      writeln;
      center ('E)nglish to ' + Language,TRUE);
      center (copy(Language,1,1) + ')' + copy(Language,2,length(Language)-1)
                + ' to English',TRUE);
      if T
        then
          center ('R)andom ordering',TRUE);
      writeln;
      ch := copy(Language,1,1);
      ch := UpCase(ch);
      ReadResponse(['E',ch,'R']);
      SetSequence := (Response = 'E')
    end;


  procedure StudyReport(Np, Nc: integer; TestFlag: boolean; WList: WordList;
                        WName: ListName; TArray: Ordering);
  { tell 'em how they did }
    var
      PctCorrect : real;
      Header     : AnyString;
      i, j       : integer;
    begin
      If TestFlag
        then
          Header := 'Test For Mastery'
        else
          Header := 'Study a List';
      PrintPageHeader(Header);
      writeln;
      center ('Results for list ' + WName,TRUE);
      writeln;
      spaces(25);
      writeln ('Number of word-pairs: ',Np);
      spaces(25);
      writeln ('Number correct      : ',Nc);
      spaces(25);
      PctCorrect := (Nc / Np) * 100.0;
      writeln ('Percentage          : ',PctCorrect:4:1);
      if TestFlag and (Nc < Np)
        then
          begin
            writeln;
            center ('You probably need to study these words a bit more:',TRUE);
            writeln;
            for i := 1 to  Np do
              begin
                if TArray[i] = 1
                  then
                    begin
                      j := 36 - length(WList[i].EnglishWord);
                      spaces (j);
                      writeln (WList[i].EnglishWord,'    ',Wlist[i].ForeignWord)
                    end
              end
          end;
      pause
    end;